COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 2 Way Matcher
C00011 ENDMK
C⊗;
;;; 2 Way Matcher
;;; Here are the macros which define the simple hunk structure case

(DECLARE (FASLOAD STRUCT FAS DSK (MAC LSP)))
(DECLARE (SETQ DEFMACRO-FOR-COMPILING ()))

(DEFSTRUCT MSTATE 
	   CURRENT-OBJECT
	   STACK
	   (PUNTED ())
	   (NULLP ())
	   (ATOMIC ())
	   H-STRUCT 
	   (SIZE 0) 
	   (CURRENT-INDEX 0) )

(DEFUN %%ADVANCE (N SIZE)
       (COND ((= N (1- SIZE)) 0)
	     (T (1+ N))))

(DEFUN P-ATOMIC (X) 
       (ATOMIC X))

(DEFUN P-CURRENT-ATOMIC (X)
       (NOT (HUNKP (CURRENT-OBJECT X))))

(DEFUN P-UNDECOMPOSABLE (X)
       (OR (NULL X)(ATOM X)(NULLP X) (ATOMIC X)))

(DEFMACRO P-CURRENT (X) 
       `(CURRENT-OBJECT ,X))

(DEFMACRO P-CURRENT-OBJECT (X) 
       `(CURRENT-OBJECT ,X))


(DEFUN P-ADVANCE (X)
       (COND ((PUNTED X)
	      (MAKE-MSTATE NULLP (NULL X)
			   ATOMIC ()
			   STACK (CDR (STACK X))
			   PUNTED T
			   CURRENT-OBJECT (CAR (STACK X))
			   SIZE (SIZE X)
			   CURRENT-INDEX 0
			   H-STRUCT ()))
	     (T (LET ((N (%%ADVANCE (CURRENT-INDEX X)
				    (SIZE X))))
		     (MAKE-MSTATE NULLP (= 0 (CURRENT-INDEX X))
				  ATOMIC ()
				  STACK ()
				  PUNTED ()
				  CURRENT-OBJECT (CXR N (H-STRUCT X))
				  SIZE (SIZE X)
				  CURRENT-INDEX N
				  H-STRUCT (H-STRUCT X))))))

(DEFMACRO P-VAR-TYPE (ATOM) 
	  ;; returns the 1st character of a P-atomic object
	  `(COND ((EQ (TYPEP ,ATOM) 'SYMBOL) (GETCHAR ,ATOM 1.))))

(DEFMACRO P-CHANGE-CURRENT (X Y) `(PROGN (SETF (CURRENT-OBJECT ,X) ,Y)
					 ,X))

(DEFUN P-CHANGE (X Y) 
 (COND ((HUNKP Y)
	(MAKE-MSTATE NULLP ()
		     ATOMIC ()
		     STACK ()
		     PUNTED ()
		     CURRENT-OBJECT (CXR 1 Y)
		     SIZE (HUNKSIZE Y)
		     CURRENT-INDEX 1
		     H-STRUCT Y)) 
       (T
	(MAKE-MSTATE NULLP (NULL Y)
		     ATOMIC T
		     STACK ()
		     PUNTED ()
		     CURRENT-OBJECT Y
		     SIZE 0
		     CURRENT-INDEX 0
		     H-STRUCT ())) ))

(DEFMACRO P-RESTRICT-VAR (X) `(CADR ,X))

(DEFUN P-MAP-BUILD (FUN H)
 (COND ((NULLP H) ())
       (T (CONS (FUNCALL FUN (CURRENT-OBJECT H))
		(P-MAP-BUILD FUN (P-ADVANCE H))))))

(DEFMACRO P-CURRENT-EMPTY (X) `(NULL (CURRENT-OBJECT ,X)))

(DEFMACRO P-EMPTY (X) `(NULLP ,X))

(DEFUN P-LISTIFY (X)
       (COND ((NULLP X) ())
	     ((PUNTED X) (STACK X))
	     (T (LET ((SIZE (SIZE X))
		      (H (H-STRUCT X)))
		     (DO ((I (CURRENT-INDEX X) (%%ADVANCE I SIZE))
			  (A ()))
			 ((= 0 I) (CONS (CXR 0 H) (NREVERSE A)))
			 (PUSH (CXR I H) A))))))

(DEFUN P-LISTIFY-REST (X)
       (COND ((NULLP X) ())
	     ((PUNTED X) (STACK X))
	     (T (LET ((SIZE (SIZE X))
		      (H (H-STRUCT X)))
		     (DO ((I (%%ADVANCE (CURRENT-INDEX X) SIZE) 
			     (%%ADVANCE I SIZE))
			  (A ()))
			 ((= 0 I) (CONS (CXR 0 H) (NREVERSE A)))
			 (PUSH (CXR I H) A))))))

(DEFMACRO P-RESTRICT-FUNS (X) `(CDDR ,X))

(DEFMACRO P-RESTRICTP (%/#X) `(AND (EQ (TYPEP ,%/#X) 'LIST)
				   (MEMQ (CAR ,%/#X) 
					 '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR))))

(DEFMACRO P-IRESTRICTP (%/#X) `(AND (EQ (TYPEP ,%/#X) 'LIST)
				   (MEMQ (CAR ,%/#X) 
					 '($IR IRESTRICT ⊗IR))))


(DEFMACRO P-FRESTRICTP (%/#X) `(AND (EQ (TYPEP ,%/#X) 'LIST)
				   (MEMQ (CAR ,%/#X) 
					 '($R RESTRICT ⊗R))))

(DEFMACRO P-RESTRICT-VAR (X) `(CADR ,X))


(DEFMACRO P-RESTRICT-TYPE (X) `(CAR ,X))

(DEFMACRO P-CREATE-RESTRICTION (X Y Z)
	  `(CONS ,X (CONS ,Y  ,Z)))

(DEFUN P-ADD-ITEM (X ITEM)
 (MAKE-MSTATE 
	   CURRENT-OBJECT ITEM
	   STACK (CONS (CURRENT-OBJECT X) (STACK X))
	   PUNTED (PUNTED X)
	   NULLP ()
	   ATOMIC (ATOMIC X)
	   H-STRUCT  (H-STRUCT X)
	   SIZE (SIZE X)
	   CURRENT-INDEX (CURRENT-INDEX X)))

(DEFUN P-ADD-ITEMS (X ITEMS)
 (MAKE-MSTATE 
	   CURRENT-OBJECT (CAR ITEMS)
	   STACK (APPEND (CDR ITEMS)
			 (CONS (CURRENT-OBJECT X) (STACK X)))
	   PUNTED (PUNTED X)
	   NULLP ()
	   ATOMIC (ATOMIC X)
	   H-STRUCT  (H-STRUCT X)
	   SIZE (SIZE X)
	   CURRENT-INDEX (CURRENT-INDEX X)))

(DEFUN P-REST-EMPTY (X)
       (COND ((NULLP X) T)
	     ((PUNTED X) (NULL (STACK X)))
	     (T (= (CURRENT-INDEX X) 0))))

(DEFUN P-CREATE-STATE (X)
       (MAKE-MSTATE NULLP ()
		    ATOMIC ()
		    STACK ()
		    PUNTED ()
		    CURRENT-OBJECT (CXR 1 X)
		    SIZE (HUNKSIZE X)
		    CURRENT-INDEX 1
		    H-STRUCT X)))

(DEFUN P-CHANGE-CURRENT-ITEMS (X ITEMS)
       (SETF (NULLP X) ())
       (SETF (STACK X)
	     (APPEND (CDR ITEMS) (STACK X)))
       (SETF (CURRENT-OBJECT X) (CAR ITEMS))
       X)

(DEFUN P-CREATE-NULL-STATE ()
       (MAKE-MSTATE NULLP T
		    ATOMIC ()
		    STACK ()
		    PUNTED T
		    CURRENT-OBJECT ()
		    SIZE 0
		    CURRENT-INDEX 0
		    H-STRUCT ()))

(DEFUN P-CREATE-STATE-FROM-CURRENT (X)
       (LET ((Y (CURRENT-OBJECT X)))
	    (COND ((HUNKP Y)
		   (MAKE-MSTATE NULLP ()
				ATOMIC ()
				STACK ()
				PUNTED ()
				CURRENT-OBJECT (CXR 1 Y)
				SIZE (HUNKSIZE Y)
				CURRENT-INDEX 1
				H-STRUCT Y)) 
		  (T
		   (MAKE-MSTATE NULLP (NULL Y)
				ATOMIC T
				STACK ()
				PUNTED ()
				CURRENT-OBJECT Y
				SIZE 0
				CURRENT-INDEX 0
				H-STRUCT ())) )))

(DEFMACRO P-CHECK (X) X)

(EVAL-WHEN (COMPILE EVAL)
	   (SSTATUS FEATURES SYMMETRIC))

(INCLUDE "GMATCH.125")